home *** CD-ROM | disk | FTP | other *** search
/ Delphi 2.0 - Programmer's Utilities Power Pack / Delphi 2.0 Programmer's Utilities Power Pack.iso / e_to_l / imlib201 / bimage.pas < prev    next >
Pascal/Delphi Source File  |  1996-09-15  |  8KB  |  311 lines
  1. {Part of Imagelib VCL/DLL Library.
  2.  
  3. Written by Jan Dekkers and Kevin Adams}
  4.  
  5. {this unit uses the tmultiimage component which must be added, select
  6.  Options/Install Components/Add and add reg_im20.pas}
  7.  
  8.  
  9. unit Bimage;
  10.  
  11. interface
  12.  
  13. uses
  14.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  15.   Forms, Dialogs, StdCtrls, FileCtrl, TMULTI, VBXCtrl, Switch, Spin,
  16.   Buttons, BFullscr, Menus, Babout;
  17.  
  18. type
  19.   TForm1 = class(TForm)
  20.     DriveComboBox1: TDriveComboBox;
  21.     DirectoryListBox1: TDirectoryListBox;
  22.     FileListBox1: TFileListBox;
  23.     MultiImage1: TMultiImage;
  24.     Convert: TBitBtn;
  25.     QualitySpin: TSpinEdit;
  26.     Smoothspin: TSpinEdit;
  27.     QualityLabel: TLabel;
  28.     SmoothLabel: TLabel;
  29.     GroupBox1: TGroupBox;
  30.     res4: TRadioButton;
  31.     res24: TRadioButton;
  32.     res8: TRadioButton;
  33.     GroupBox2: TGroupBox;
  34.     Label5: TLabel;
  35.     Label6: TLabel;
  36.     Label7: TLabel;
  37.     DitherOneNo: TRadioButton;
  38.     DitherOneYes: TRadioButton;
  39.     DitherTwoNo: TRadioButton;
  40.     DitherTwoYes: TRadioButton;
  41.     Dither24Bit: TRadioButton;
  42.     MainMenu1: TMainMenu;
  43.     N1: TMenuItem;
  44.     E1: TMenuItem;
  45.     A1: TMenuItem;
  46.     ComboBox1: TComboBox;
  47.     Sstretch: TCheckBox;
  48.     GroupBox3: TGroupBox;
  49.     CTOJPEG: TRadioButton;
  50.     CTOBMP: TRadioButton;
  51.     Label1: TLabel;
  52.     FileListBox2: TFileListBox;
  53.     DirectoryListBox2: TDirectoryListBox;
  54.     DriveComboBox2: TDriveComboBox;
  55.     Label2: TLabel;
  56.     Label3: TLabel;
  57.     procedure DriveComboBox1Change(Sender: TObject);
  58.     procedure DirectoryListBox1Change(Sender: TObject);
  59.     procedure FileListBox1Change(Sender: TObject);
  60.     procedure SstretchOnOff(Sender: TObject);
  61.     procedure FormCreate(Sender: TObject);
  62.     procedure resClick(Sender: TObject);
  63.     procedure DitherClick(Sender: TObject);
  64.     procedure MultiImage1Click(Sender: TObject);
  65.     procedure E1Click(Sender: TObject);
  66.     procedure A1Click(Sender: TObject);
  67.     procedure FormClose(Sender: TObject; var Action: TCloseAction);
  68.     procedure ComboBox1Change(Sender: TObject);
  69.     procedure ConvertClick(Sender: TObject);
  70.     procedure DirectoryListBox2Change(Sender: TObject);
  71.     procedure DriveComboBox2Change(Sender: TObject);
  72.     procedure FileListBox2Change(Sender: TObject);
  73.     procedure QualitySpinChange(Sender: TObject);
  74.     procedure SmoothspinChange(Sender: TObject);
  75.   private
  76.     function NameOnly(PName : string) : string;
  77.   public
  78.     { Public declarations }
  79.   end;
  80.  
  81. var
  82.   Form1: TForm1;
  83.  
  84. implementation
  85.  
  86. {$R *.DFM}
  87.  
  88. {update the drive of DirectoryListBox1 with the drive of DriveComboBox1}
  89. procedure TForm1.DriveComboBox1Change(Sender: TObject);
  90. begin
  91.   DirectoryListBox1.Drive := DriveComboBox1.Drive;
  92. end;
  93.  
  94. {update the directory of FileListBox1 with the directory of FileListBox1}
  95. procedure TForm1.DirectoryListBox1Change(Sender: TObject);
  96. begin
  97.        FileListBox1.Directory := DirectoryListBox1.Directory;
  98. end;
  99.  
  100. {Display the image of the FileListBox1.filename}
  101. procedure TForm1.FileListBox1Change(Sender: TObject);
  102. begin
  103.  {set hourglass cursor}
  104.   screen.cursor:=crHourGlass;
  105.  try
  106.  {display an image using the vcl}
  107.   MultiImage1.imagename:=FileListBox1.filename;
  108.  finally
  109.   {set default cursor}
  110.   screen.cursor:=crDefault;
  111.  end;
  112. end;
  113.  
  114. procedure TForm1.FileListBox2Change(Sender: TObject);
  115. begin
  116.  {set hourglass cursor}
  117.   screen.cursor:=crHourGlass;
  118.  try
  119.  {display an image using the vcl}
  120.   MultiImage1.imagename:=FileListBox2.filename;
  121.  finally
  122.   {set default cursor}
  123.   screen.cursor:=crDefault;
  124.  end;
  125. end;
  126.  
  127. {set strech mode}
  128. procedure TForm1.SstretchOnOff(Sender: TObject);
  129. begin
  130.   MultiImage1.stretch:=Sstretch.Checked;
  131. end;
  132.  
  133.  
  134. {what we do on create}
  135. procedure TForm1.FormCreate(Sender: TObject);
  136. begin
  137.     {set the value of the QualitySpin to the value of JPegSaveQuality}
  138.     QualitySpin.value:=MultiImage1.JPegSaveQuality;
  139.  
  140.     {set the value of the Smoothspin to the value of JPegSaveSmooh}
  141.     Smoothspin.value:=MultiImage1.JPegSaveSmooth;
  142.  
  143. end;
  144.  
  145. {Set the jpeg resolution to either 16, 256 or true color in the vcl}
  146. procedure TForm1.resClick(Sender: TObject);
  147. begin
  148.  {set jpeg show resolution to 4 bit 16 color}
  149.  if res4.checked  then MultiImage1.JPegResolution:=4;
  150.  
  151.  {set jpeg show resolution to 8 bit 256 color}
  152.  if res8.checked  then MultiImage1.JPegResolution:=8;
  153.  
  154.  {set jpeg show resolution to 24 bit true color}
  155.  if res24.checked then MultiImage1.JPegResolution:=24;
  156. end;
  157.  
  158.  
  159. {Set the jpeg dither in the vcl}
  160. procedure TForm1.DitherClick(Sender: TObject);
  161. begin
  162.   {set the jpeg show dither to none (best choice for true color 24 bit}
  163.   if Dither24Bit.checked  then MultiImage1.JPegDither:=0;
  164.  
  165.   {set the jpeg show dither to one pass none}
  166.   if DitherOneNo.checked  then MultiImage1.JPegDither:=1;
  167.  
  168.   {set the jpeg show dither to one pass dithered (best choice for 16 colors)}
  169.   if DitherOneYes.checked  then MultiImage1.JPegDither:=2;
  170.  
  171.   {set the jpeg show dither to one pass none}
  172.   if DitherTwoNo.checked  then MultiImage1.JPegDither:=3;
  173.  
  174.   {set the jpeg show dither to two pass dithered (best choice for 256 colors)}
  175.   if DitherTwoYes.checked  then MultiImage1.JPegDither:=4;
  176. end;
  177.  
  178.  
  179. {show fullscreen}
  180. procedure TForm1.MultiImage1Click(Sender: TObject);
  181. begin
  182.   {copy image to fullscreen image}
  183.   FullSlide.MultiImage1.Picture.Graphic:=MultiImage1.Picture.Graphic;
  184.   {show the image fulscreen}
  185.   FullSlide.showmodal;
  186. end;
  187.  
  188. {exit the program}
  189. procedure TForm1.E1Click(Sender: TObject);
  190. begin
  191.  close;
  192. end;
  193.  
  194. {about box}
  195. procedure TForm1.A1Click(Sender: TObject);
  196. begin
  197. {Copy the image to the image of he about box}
  198.  AboutBox.MultiImage1.Picture.Graphic:=MultiImage1.Picture.Graphic;
  199. {show the about box}
  200.  AboutBox.showmodal;
  201. end;
  202.  
  203. {what to do on exit}
  204. procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
  205. begin
  206. {}
  207. end;
  208.  
  209. procedure TForm1.ComboBox1Change(Sender: TObject);
  210. begin
  211.  FileListBox1.Mask:=ComboBox1.text;
  212.  FileListBox1.Update;
  213. end;
  214.  
  215.  
  216. {return filename only. no path, no extension}
  217. function TForm1.NameOnly(PName : string) : string;
  218.  var
  219.    DtP : Byte;
  220.  
  221.  function JName(PName : string) : string;
  222.   var
  223.     I : Word;
  224.   const
  225.     DDSet : set of Char = ['\', ':', #0];
  226.   begin
  227.     I := Succ(Word(Length(PName)));
  228.     repeat
  229.       Dec(I);
  230.     until (PName[I] in DDSet) or (I = 0);
  231.     JName := Copy(PName, Succ(I), 64);
  232.   end;
  233.  
  234.   begin
  235.     PName := JName(PName);
  236.     DtP := Pos('.', PName);
  237.     if DtP > 0 then
  238.       PName := Copy(PName, 1, DtP-1);
  239.     NameOnly := PName;
  240.   end;
  241.  
  242.  
  243.  
  244. {The actual conversion}
  245. procedure TForm1.ConvertClick(Sender: TObject);
  246. var i          : integer;
  247.     pTempExt   : string[4];
  248.     pExtension : string[4];
  249.     pName      : string[13];
  250.     pPath      : string[100];
  251.     toTemp      : string;
  252.     frTemp      : string;
  253. begin
  254.  Label3.CapTion:='';
  255.  
  256.  if CTOJPEG.Checked then
  257.     pTempExt:='.JPG'
  258.  else
  259.     pTempExt:='.BMP';
  260.  
  261.  for i:=0 to FileListBox1.items.count-1 do begin
  262.      if FileListBox1.Selected[i] then begin
  263.  
  264.        pExtension:=UpperCase(ExtractFileExt(FileListBox1.Items.Strings[i]));
  265.        pName:=UpperCase(NameOnly(FileListBox1.Items.Strings[i]));
  266.        pPath:=UpperCase(DirectoryListBox2.Directory);
  267.  
  268.        toTemp:=pPath+'\'+pName+pTempExt;
  269.        frTemp:=UpperCase(DirectoryListBox1.Directory+'\'+FileListBox1.Items.Strings[i]);
  270.        {set hourglass cursor}
  271.         screen.cursor:=crHourGlass;
  272. try
  273.        if CTOJPEG.Checked then begin
  274.         MultiImage1.imagename:=frTemp;
  275.         MultiImage1.SaveAsJpg(toTemp)
  276.        end else begin
  277.         MultiImage1.imagename:=frTemp;
  278.         MultiImage1.Picture.SaveToFile(toTemp);
  279.        end;
  280. finally
  281.       {set default cursor}
  282.       screen.cursor:=crDefault;
  283.       FileListBox2.UpDate;
  284. end;
  285.       end;
  286.       Label3.CapTion:='DONE';
  287.  end;
  288. end;
  289.  
  290. procedure TForm1.DirectoryListBox2Change(Sender: TObject);
  291. begin
  292.   FileListBox2.Directory := DirectoryListBox2.Directory;
  293. end;
  294.  
  295. procedure TForm1.DriveComboBox2Change(Sender: TObject);
  296. begin
  297.   DirectoryListBox2.Drive := DriveComboBox2.Drive;
  298. end;
  299.  
  300. procedure TForm1.QualitySpinChange